home *** CD-ROM | disk | FTP | other *** search
/ MacHack 1996 / MacHack 1996.toast / Hacks / Hacks ’92 / ScreenSaver?!!! / MacHack Orig.lisp next >
Encoding:
Text File  |  1992-06-18  |  7.6 KB  |  234 lines  |  [TEXT/CCL2]
  1. ;;;;ADLM.lisp
  2. ;;;;AfterDark LISP Module written in Macintosh Common LISP.
  3. ;;;;This is the (non-gratuitously) largest AfterDark Module you will ever see.
  4. ;;;;Special thanks to all the people I bugged with idiotic ToolBox questions.
  5.  
  6.  
  7. (require :quickdraw)
  8.  
  9. (defparameter *edge-cutoff* 5
  10.   "The cutoff when a pixel is outweighed by its neighbors."
  11. )
  12. (defparameter *cedge-cutoff* (floor (* .3 *white-color*))
  13.   "When things aren't Black&White anymore…use *edge-cutoff*."
  14. )
  15. (defparameter *debugs* nil
  16.   "A list of keywords to test to see if I want to output some debugging stuff."
  17. )
  18.  
  19. (defun ADLM-black (&optional (port (wptr (select-window))))
  20.   "port
  21. Does not-so-funky screen-saver things to port…paints all of port black."
  22.   (with-port port
  23.     (with-fore-color *black-color*
  24.       (#_FillRgn (rref port :GrafPort.visrgn) *black-pattern*)
  25. ) ) )
  26.  
  27. (defun ADLM-black-hole (&optional (port (wptr (select-window))))
  28.   "port
  29. Does funky screen-saver things to port.
  30. Specifically, it uses standard AI-vision edge-detection to find objects in
  31. the port, and then blacks-out/restores randomly selected objects."
  32.  
  33.   (when (member :original *debugs*)
  34.     (make-instance 'window :wptr port :color-p *color-available*)
  35.   )
  36.  
  37.   ;Get a copy of the port and/or force it into a CGrafPort
  38.   (rlet ((c-port :CGrafPort)
  39.          (laplace-port :CGrafPort)
  40.          (shaper-port :CGrafPort)
  41.          (cpix :RGBColor)
  42.          (colorp (color-grafport-p port))
  43.         )
  44.     (if colorp
  45.       (%setf-macptr c-port port)
  46.       ;Get a B/W into a CGrafPort somehow…maybe next year.   NOT!
  47.       ;Although I can't handle B&W yet, I do exit gracefully.
  48.       (without-interrupts
  49.         (make-instance 'window
  50.           :window-type :single-edge-box
  51.           :view-position :centered
  52.           :view-size #@(600 100)
  53.           :view-subviews
  54.           (list
  55.             (make-instance 'static-text-dialog-item
  56.               :dialog-item-text "I don't do Black and White."
  57.               :view-font '("Geneva" 40)
  58.               :view-position #@(50 20)
  59.         ) ) )
  60.         (sleep 10)
  61.         (return-from 'ADLM-black-hole)
  62.       )
  63.     )
  64.  
  65.     (when (member :copy *debugs*)
  66.       (make-instance 'window :port c-port :color-p *color-available*)
  67.     )
  68.  
  69.     ;Get some useful size numbers.
  70.     (let* ((pixmap (rref c-port :CGrafPort.PixMap))
  71.            (bail (unless (handlep pixmap) (return-from ADLM-black-hole)))
  72.            (left (rref pixmap :PixMap.Bounds.left))
  73.            (top (rref pixmap :PixMap.Bounds.top))
  74.            (right (rref pixmap :PixMap.Bounds.right))
  75.            (bottom (rref pixmap :PixMap.Bounds.bottom))
  76.            (width (- right left))
  77.            (height (- bottom top))
  78.            (laplace (rref laplace-port :CGrafPort.PixMap))
  79.            (bail (unless (handlep laplace (return-from ADLM-black-hole))))
  80.            (shaper (rref shaper-port :CGrafPort.PixMap))
  81.            (bail (unless (handlep shaper (return-from ADLM-black-hole))))
  82.            (l-bounds (rref laplace :PixMap.Bounds))
  83.            (s-bounds (rref shaper :PixMap.Bounds))
  84.            (shapes nil)
  85.           )
  86.       (declare (ignore bail))
  87.  
  88.       (unwind-protect
  89.  
  90.         ;Protected form
  91.         (progn
  92.  
  93.           ;Compute LaPlacian transformation from c-port to laplace
  94.           
  95.           (with-focused-view laplace-port
  96.             ;Forshadowing…
  97.             ;By definition, the edge of the PixMap is… well… the edge.
  98.             (dotimes (h width)
  99.               (#_SetCPixel h 0 *black-rgb*)
  100.               (#_SetCPixel h height *black-rgb*)
  101.             )
  102.             (dotimes (v height)
  103.               (#_SetCPixel 0 v *black-rgb*)
  104.               (#_SetCPixel 0 width *black-rgb*)
  105.             )
  106.             (dotimes (h (- width 2))
  107.               (dotimes (v (- height 2))
  108.                 (#_SetCPixel (1+ h) (1+ v)
  109.                   (color-to-rgb
  110.                     (with-focused-view c-port
  111.                       (- (* 8 (get-c-color (1+ h) (1+ v) rgb))
  112.                          (get-c-color h v rgb)
  113.                          (get-c-color (1+ h) v rgb)
  114.                          (get-c-color (+ h 2) v rgb)
  115.                          (get-c-color h (1+ v) rgb)
  116.                          ;I think I re-typed this section 8 times.
  117.                          ;And each time, I tried to put in (1+ h) (1+ v)
  118.                          ;This, of course, is the pixel I *DON'T* want.
  119.                          ;I want all its neighbors.
  120.                          (get-c-color h (+ v 2) rgb)
  121.                          (get-c-color (1+ h) (+ v 2) rgb)
  122.                          (get-c-color (+ h 2) (+ v 2) rgb)
  123.             ) ) ) ) ) )
  124.  
  125.             (when (member :laplace *debugs*)
  126.               (make-instance 'window :port laplace-port :color-p *color-available*)
  127.             )
  128.         
  129.             ;And now we map all these numbers to 0 or 1.
  130.             ;For readability, I would have another CGrafPort, edges-port, and
  131.             ;its pixmap, but then I'd have to swap ports even more than I
  132.             ;already have.
  133.             (if colorp
  134.               (dotimes (h width)
  135.                 (dotimes (v height)
  136.                   (if (< (get-c-color h v rgb) *cedge-cutoff*)
  137.                     (#_SetCPixel h v *white-rgb*)
  138.                     (#_SetCPixel h v *black-rgb*)
  139.               ) ) )
  140.               ;Now, of course, I know we can't get here, but the only
  141.               ;difference from the code above is *edge-cutoff* instead of
  142.               ;*cedge-cutoff*, so I guess I'll make it easy on myself for the
  143.               :vaporware upgrade and copy and paste in the code.
  144.               ;Aren't I the go-getter?
  145.               (dotimes (h width)
  146.                 (dotimes (v height)
  147.                   (if (< (get-c-color h v rgb) *edge-cutoff*)
  148.                     (#_SetCPixel h v *white-rgb*)
  149.                     (#_SetCPixel h v *black-rgb*)
  150.               ) ) )
  151.             )
  152.  
  153.             (when (member :edges *debugs*)
  154.               (make-instance 'window :port laplace-port :color-p *color-available*)
  155.             )
  156.  
  157.             (dotimes (h width)
  158.               (dotimes (v height)
  159.                 (#_SeedCFill laplace shaper l-bounds s-bounds h v 
  160.  
  161.         ) )
  162.  
  163.           
  164.  
  165.  
  166.         ;Cleanup forms.  This code WILL execute, if a LISP error is generated
  167.         ;within the protected form (starts with progn) above.
  168.         (#_DisposeHandle laplace)
  169.         (#_DisposeHandle edges)
  170.         (#_DiseposeHandle shaper)
  171.       )
  172. ) ) )
  173.  
  174. ;;;;A short function to shorten my typing.
  175. (defun get-c-color (h v rgb-ptr)
  176.   "h v rgb-ptr
  177. Calls _GetCPixel and then rgb-to-color.
  178. rgb-ptr will be remain modified."
  179.   (#_GetCPixel h v rgb-ptr)
  180.   (rgb-to-color rgb-ptr)
  181. )
  182.  
  183.  
  184. ;;;;An array window takes a LISP array and draws it as a BitMap/PixMap.
  185. (defclass array-window (window)
  186.   ((array
  187.      :documentation "An array to display."
  188.      :accessor array
  189.      :initarg :array
  190.      :initform #()
  191.      :type 'array
  192.    )
  193.   )
  194.   (:default-initargs
  195.     :color-p *color-available*
  196. ) )
  197.  
  198. (defmethod initialize-instance :after ((view array-window) &key (array #() array-supplied-p))
  199.   (when array-supplied-p
  200.     (apply #'set-view-size view (array-dimensions array))
  201. ) )
  202.  
  203. (defmethod view-draw-contents :after ((view array-window))
  204.   (let* ((array (array view))
  205.          (dims (array-dimensions array))
  206.          (width (car dims))
  207.          (height (cadr dims))
  208.         )
  209.     (dotimes (h width)
  210.       (dotimes (v height)
  211.         (#_ForeColor (aref array h v))
  212.         (#_MoveTo h v)
  213.         (#_LineTo h v)
  214. ) ) ) )
  215.  
  216.  
  217. (defun select-window ()
  218.   "Allows the user to select any visible window."
  219.   (car (select-item-from-list (windows)))
  220. )
  221.  
  222. (defun color-grafport-p (port)
  223.   "port
  224. Returns T iff port is a CGrafPort."
  225. #|
  226.   (let* ((pixmap (rref port :CGrafPort.PortPixMap))
  227.          (rowbytes (rref pixmap :PixMap.RowBytes))
  228.         )
  229.     (zerop (logand rowbytes #b0000000000000001))
  230.   )
  231. |#
  232.   (declare (ignore port))
  233.   t
  234. )